home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Net / Time.pm < prev   
Encoding:
Perl POD Document  |  2009-06-26  |  3.3 KB  |  152 lines
  1. # Net::Time.pm
  2. #
  3. # Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6.  
  7. package Net::Time;
  8.  
  9. use strict;
  10. use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
  11. use Carp;
  12. use IO::Socket;
  13. require Exporter;
  14. use Net::Config;
  15. use IO::Select;
  16.  
  17. @ISA       = qw(Exporter);
  18. @EXPORT_OK = qw(inet_time inet_daytime);
  19.  
  20. $VERSION = "2.10";
  21.  
  22. $TIMEOUT = 120;
  23.  
  24.  
  25. sub _socket {
  26.   my ($pname, $pnum, $host, $proto, $timeout) = @_;
  27.  
  28.   $proto ||= 'udp';
  29.  
  30.   my $port = (getservbyname($pname, $proto))[2] || $pnum;
  31.  
  32.   my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'};
  33.  
  34.   my $me;
  35.  
  36.   foreach $host (@$hosts) {
  37.     $me = IO::Socket::INET->new(
  38.       PeerAddr => $host,
  39.       PeerPort => $port,
  40.       Proto    => $proto
  41.       )
  42.       and last;
  43.   }
  44.  
  45.   return unless $me;
  46.  
  47.   $me->send("\n")
  48.     if $proto eq 'udp';
  49.  
  50.   $timeout = $TIMEOUT
  51.     unless defined $timeout;
  52.  
  53.   IO::Select->new($me)->can_read($timeout)
  54.     ? $me
  55.     : undef;
  56. }
  57.  
  58.  
  59. sub inet_time {
  60.   my $s      = _socket('time', 37, @_) || return undef;
  61.   my $buf    = '';
  62.   my $offset = 0 | 0;
  63.  
  64.   return undef
  65.     unless defined $s->recv($buf, length(pack("N", 0)));
  66.  
  67.   # unpack, we | 0 to ensure we have an unsigned
  68.   my $time = (unpack("N", $buf))[0] | 0;
  69.  
  70.   # the time protocol return time in seconds since 1900, convert
  71.   # it to a the required format
  72.  
  73.   if ($^O eq "MacOS") {
  74.  
  75.     # MacOS return seconds since 1904, 1900 was not a leap year.
  76.     $offset = (4 * 31536000) | 0;
  77.   }
  78.   else {
  79.  
  80.     # otherwise return seconds since 1972, there were 17 leap years between
  81.     # 1900 and 1972
  82.     $offset = (70 * 31536000 + 17 * 86400) | 0;
  83.   }
  84.  
  85.   $time - $offset;
  86. }
  87.  
  88.  
  89. sub inet_daytime {
  90.   my $s   = _socket('daytime', 13, @_) || return undef;
  91.   my $buf = '';
  92.  
  93.   defined($s->recv($buf, 1024))
  94.     ? $buf
  95.     : undef;
  96. }
  97.  
  98. 1;
  99.  
  100. __END__
  101.  
  102. =head1 NAME
  103.  
  104. Net::Time - time and daytime network client interface
  105.  
  106. =head1 SYNOPSIS
  107.  
  108.     use Net::Time qw(inet_time inet_daytime);
  109.  
  110.     print inet_time();        # use default host from Net::Config
  111.     print inet_time('localhost');
  112.     print inet_time('localhost', 'tcp');
  113.  
  114.     print inet_daytime();    # use default host from Net::Config
  115.     print inet_daytime('localhost');
  116.     print inet_daytime('localhost', 'tcp');
  117.  
  118. =head1 DESCRIPTION
  119.  
  120. C<Net::Time> provides subroutines that obtain the time on a remote machine.
  121.  
  122. =over 4
  123.  
  124. =item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
  125.  
  126. Obtain the time on C<HOST>, or some default host if C<HOST> is not given
  127. or not defined, using the protocol as defined in RFC868. The optional
  128. argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
  129. C<udp>. The result will be a time value in the same units as returned
  130. by time() or I<undef> upon failure.
  131.  
  132. =item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
  133.  
  134. Obtain the time on C<HOST>, or some default host if C<HOST> is not given
  135. or not defined, using the protocol as defined in RFC867. The optional
  136. argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
  137. C<udp>. The result will be an ASCII string or I<undef> upon failure.
  138.  
  139. =back
  140.  
  141. =head1 AUTHOR
  142.  
  143. Graham Barr <gbarr@pobox.com>
  144.  
  145. =head1 COPYRIGHT
  146.  
  147. Copyright (c) 1995-2004 Graham Barr. All rights reserved.
  148. This program is free software; you can redistribute it and/or modify
  149. it under the same terms as Perl itself.
  150.  
  151. =cut
  152.